* 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.
16 files changed:
(defun prototypes-for-make-method-lambda (name)
(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))))
(values nil nil)
(let ((gf? (and (fboundp name)
(gdefinition name))))
(defun method-prototype-for-gf (name)
(let ((gf? (and (fboundp name)
(gdefinition name))))
(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.
((or (null gf?)
(not (generic-function-p gf?))) ; Someone else MIGHT
; error at load time.
(declare (ignore env proto-gf proto-method))
(flet ((parse (name)
(cond
(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))
(specializerp name))
name)
((symbolp name) `(find-class ',name))
;; cases by blacklisting them here. -- WHN 2001-01-19
(list 'slot-object #+nil (find-class 'slot-object)))
'(ignorable))
;; 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
;; 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
(defun generic-function-name-p (name)
(and (legal-fun-name-p name)
(fboundp name)
(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
(standard-generic-function-p (gdefinition name))
(funcallable-instance-p (gdefinition name)))))
\f
(defun load-defmethod-internal
(method-class gf-spec qualifiers specializers lambda-list
initargs source-location)
(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)
(fboundp gf-spec))
(let* ((gf (fdefinition gf-spec))
(method (and (generic-function-p gf)
(let ((existing (and (fboundp fun-name)
(gdefinition fun-name))))
(cond ((and existing
(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)
(null (generic-function-p existing)))
(generic-clobbers-function fun-name)
(fmakunbound fun-name)
+slot-unbound+))))
(early-collect-inheritance 'standard-generic-function)))
+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)
(!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+)
-(defvar *sgf-methods-index*
+(defconstant +sgf-methods-index+
(!bootstrap-slot-index 'standard-generic-function 'methods))
(defmacro early-gf-methods (gf)
(!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*)
(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)))
(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)
(!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
(!bootstrap-slot-index 'standard-generic-function 'dfun-state))
(defstruct (arg-info
(defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
argument-precedence-order)
(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)))
(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)))
(generic-function-methods gf)
(early-gf-methods gf)))
(was-valid-p (integerp (arg-info-number-optional arg-info)))
-(defvar *sm-specializers-index*
+(defconstant +sm-specializers-index+
(!bootstrap-slot-index 'standard-method 'specializers))
(!bootstrap-slot-index 'standard-method 'specializers))
-(defvar *sm-%function-index*
+(defconstant +sm-%function-index+
(!bootstrap-slot-index 'standard-method '%function))
(!bootstrap-slot-index 'standard-method '%function))
-(defvar *sm-qualifiers-index*
+(defconstant +sm-qualifiers-index+
(!bootstrap-slot-index 'standard-method 'qualifiers))
(!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.
;;; 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)
(!bootstrap-slot-index 'standard-reader-method s)
(!bootstrap-slot-index 'standard-writer-method s)
(!bootstrap-slot-index 'standard-boundp-method s)
(!bootstrap-slot-index 'global-writer-method s)
(!bootstrap-slot-index 'global-boundp-method s))))
(!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)
(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)
(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)
(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))
(defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
(let* ((existing-p (and methods (cdr methods) new-method))
nil)))
(when (arg-info-valid-p arg-info)
(dolist (method (if new-method (list new-method) methods))
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)))
(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
(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*)
(eq (generic-function-method-combination gf)
*standard-method-combination*)))
(cond ((or (eq class *the-class-standard-reader-method*)
(unless (gf-info-c-a-m-emf-std-p arg-info)
(setf (gf-info-simple-accessor-type arg-info) t))))
(unless was-valid-p
(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)
(generic-function-name gf)
(!early-gf-name gf))))
(setf (gf-precompute-dfun-and-emf-p arg-info)
;; remain.
(not (find #\Space (symbol-name symbol))))))))))
(setf (gf-info-fast-mf-p arg-info)
;; 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
(let* ((method-class (generic-function-method-class gf))
(methods (compute-applicable-methods
#'make-method-lambda
(defun safe-gf-dfun-state (generic-function)
(if (eq (class-of generic-function) *the-class-standard-generic-function*)
(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*)
(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)))
new-value)
(setf (gf-dfun-state generic-function) new-value)))
(list* dfun cache info)
dfun)))
(cond
(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
;; 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)
new-state))))
dfun)
(defun gf-dfun-cache (gf)
- (let ((state (if (eq *boot-state* 'complete)
+ (let ((state (if (eq **boot-state** 'complete)
- (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)
(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)
- (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)))))
(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)
(!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)
(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))
(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)
(generic-function-methods gf)
(early-gf-methods gf))))
(if (null methods)
(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)
(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)
(gf-arg-info generic-function)))
;;; FIXME: this function took on a slightly greater role than it
(gf-arg-info generic-function)))
;;; FIXME: this function took on a slightly greater role than it
(cons (if (listp arg) (cadr arg) t) specializers)
(cons (if (listp arg) (car arg) arg) required)))))))
\f
(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
\f
;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET
;;; which used %WALKER stuff. That suggests to me that maybe the code
class name class-eq-specializer-wrapper source
direct-supers direct-subclasses cpl wrapper))))))))
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
(let* ((smc-class (find-class 'standard-method-combination))
(smc-wrapper (!bootstrap-get-slot 'standard-class
smc-class
(let ((class (classoid-pcl-class classoid)))
(cond (class
(ensure-non-standard-class (class-name class) classoid class))
(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*)
(ensure-non-standard-class (classoid-name classoid) classoid)))))
(pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*)
;;; FIXME: only needed during bootstrap
(defun make-class-predicate (class name)
(let* ((gf (ensure-generic-function name :lambda-list '(object)))
;;; 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
(early-gf-methods gf)
(generic-function-methods gf))))
(unless mlist
(%set-class-type-translation class name))))
(%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~
(defmethod no-applicable-method (generic-function &rest args)
(error "~@<There is no applicable method for the generic function ~2I~_~S~
;; or aren't to prevent the leaky next methods bug.
(let* ((cm-args (cdr form))
(fmf-p (and (null no-fmf-p)
;; 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))
(gf-fast-method-function-p generic-function))
(null (cddr cm-args))))
(method (car cm-args))
(error-p (or (eq (first effective-method) '%no-primary-method)
(eq (first effective-method) '%invalid-qualifiers)))
(mc-args-p
(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)
;; Otherwise the METHOD-COMBINATION slot is not bound.
(let ((combin (generic-function-method-combination gf)))
(and (long-method-combination-p combin)
;; 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 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
(let ((mclass (find-class metaclass nil)))
(and mclass
(*subtypep
;;; 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.)
;;; 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."))
(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."))
(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~%~
(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~%~
(when (symbolp specl)
;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
(setq specl (find-class specl)))
(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
(specializerp specl)))
(specializer-type specl))
(t
(let ((type (specializer-type class)))
(if (listp type) type `(,type)))
`(,type))))
(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
(specializerp type))
(specializer-type type))
(t
(defun *subtypep (type1 type2)
(if (equal type1 type2)
(values t t)
(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*))
(values (eq type1 type2) t)
(let ((*in-precompute-effective-methods-p* t))
(declare (special *in-precompute-effective-methods-p*))
(setf *standard-slot-locations* new)))
(defun maybe-update-standard-slot-locations (class)
(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)))
(memq (class-name class) *standard-classes*))
(compute-standard-slot-locations)))
(generic-function-methods gf)))
(default '(unknown)))
(and (null applyp)
(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.
;; If COMPUTE-APPLICABLE-METHODS is specialized, we
;; can't use this, of course, because we can't tell
;; which methods will be considered applicable.
;; method has qualifiers, to make sure that emfs are really
;; method functions; see above.
(dolist (method methods t)
;; 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))
(when (or (some #'eql-specializer-p
(safe-method-specializers method))
(safe-method-qualifiers method))
(return t)))))
(defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
(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
(unless (or caching-p
(gf-requires-emf-keyword-checks gf)
;; DISPATCH-DFUN-COST will error if it encounters a
(initial-dfun gf args))))
(multiple-value-bind (dfun cache info)
(cond
(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)))
(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
(compute-applicable-methods-emf-std-p gf))
(let* ((caching-p (use-caching-dfun-p gf))
;; KLUDGE: the only effect of this (when
(safe-method-qualifiers meth))
(return-from accessor-values-internal (values nil nil))))
(let* ((meth (car methods))
(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)
(slot-name (when accessor-class
(if (consp meth)
(and (early-method-standard-accessor-p meth)
(generic-function-methods gf)))
(all-index nil)
(no-class-slots-p t)
(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)}
first second (size 0))
(declare (fixnum size))
;; class -> {(specl slotd)}
precedence
(lambda (class1 class2 index)
(let* ((class (type-class (nth index types)))
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))
(class-precedence-list class)
(early-class-precedence-list class))))
(if (memq class2 (memq class1 cpl))
(stable-sort methods #'sorter)))
(defun order-specializers (specl1 specl2 index compare-classes-function)
(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)))
(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)
(specializer-type specl2)
(!bootstrap-get-slot 'specializer specl2 '%type))))
(cond ((eq specl1 specl2)
argument-precedence-order)))
(defun cpl-or-nil (class)
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
(progn
;; KLUDGE: why not use (slot-boundp class
;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is
(defun map-all-classes (fun &optional (root t))
(let ((all-classes (make-hash-table :test 'eq))
(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)
(labels ((do-class (class)
(unless (gethash class all-classes)
(setf (gethash class all-classes) t)
wrappers-p all-applicable-p
all-sorted-p function-p)
(if (and all-applicable-p all-sorted-p (not function-p))
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
(let* ((combin (generic-function-method-combination gf))
(effective (compute-effective-method gf combin methods)))
(make-effective-method-function1 gf effective method-alist-p
(get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p))
(defun methods-contain-eql-specializer-p (methods)
(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)))
(dolist (method methods nil)
(when (dolist (spec (method-specializers method) nil)
(when (eql-specializer-p spec) (return t)))
(dolist (s '(condition function structure-object))
(dohash ((k v) (classoid-subclasses (find-classoid s)))
(find-class (classoid-name k))))
(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))
(defun print-std-instance (instance stream depth)
(declare (ignore depth))
(when class-default-initargs
(setf initargs (default-initargs initargs class-default-initargs)))
(when initargs
(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
(not (getf initargs :allow-other-keys)))
(let ((class-proto (class-prototype class)))
(check-initargs-1
(defun set-fun-name (fun new-name)
#+sb-doc
"Set the name of a compiled function object. Return the function."
(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
(when (valid-function-name-p fun)
(setq fun (fdefinition fun)))
(typecase fun
(sb-eval:interpreted-function
(setf (sb-eval:interpreted-function-name fun) new-name))
(funcallable-instance ;; KLUDGE: probably a generic function...
(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))
(typep fun 'generic-function)
(eq (class-of fun) *the-class-standard-generic-function*))
(setf (%funcallable-instance-info fun 2) new-name))
;;; This DEFVAR was originally in defs.lisp, now moved here.
;;;
;;; Possible values are NIL, EARLY, BRAID, or COMPLETE.
;;; 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")
(/show "pcl/macros.lisp 187")
(if (and (constantp symbol)
(legal-class-name-p (setf symbol (constant-form-value symbol)))
(constantp errorp)
(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))))
(let ((errorp (not (null (constant-form-value errorp))))
(cell (make-symbol "CLASSOID-CELL")))
`(let ((,cell (load-time-value (find-classoid-cell ',symbol :create t))))
(let ((cell (find-classoid-cell name :create new-value)))
(cond (new-value
(setf (classoid-cell-pcl-class cell) new-value)
(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)))
(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
(update-ctors 'setf-find-class :class new-value :name name))
new-value)))
(t
\f
(defmethod generic-function-argument-precedence-order
((gf standard-generic-function))
\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)
(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)
(defvar *std-cam-methods* nil)
(defun compute-applicable-methods-emf (generic-function)
(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))))
(let* ((cam (gdefinition 'compute-applicable-methods))
(cam-methods (compute-applicable-methods-using-types
cam (list `(eql ,generic-function) t))))
initargs))
(defun make-std-writer-method-function (class-or-name slot-name)
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))))
(if (typep class-or-name 'class)
class-or-name
(find-class class-or-name nil))))
(vector (make-array n :initial-element nil))
(save-slot-location-p
(or bootstrap
(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
(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)))
(flet ((add-to-vector (name slot)
(declare (symbol name)
(optimize (sb-c::insert-array-bounds-checks 0)))
(slot-definition-type-check-function slot))
slot)
(svref vector index))))))
(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)
(dolist (slot slots)
(add-to-vector (slot-definition-name slot) slot))
(dolist (slot slots)
(find-slot-definition class name)))
(old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
(multiple-value-bind (function std-p)
(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)
(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)
(without-package-locks
(setf (find-class name) class))))
;; After boot (SETF FIND-CLASS) does this.
(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)
(%set-class-type-translation class name))
class)
(without-package-locks
(setf (find-class name) class))))
;; After boot (SETF FIND-CLASS) does this.
(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)
(%set-class-type-translation class name))
class)
(%intern-pv-table (mapcar #'intern-slot-names slot-name-lists)))))
\f
(defun optimize-slot-value-by-class-p (class slot-name type)
(%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)))))
(let ((slotd (find-slot-definition class slot-name)))
(and slotd
(slot-accessor-std-p slotd type)))))
parameter-or-nil
env)))
(class (find-class class-name nil)))
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)))
(and class (not (class-finalized-p class))))
(setq class nil))
(when (and class-name (not (eq class-name t)))
new-value &optional safep)
(let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
(parameter (if (consp sparameter) (car sparameter) sparameter)))
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)))
(classp class)
(memq *the-class-structure-object* (class-precedence-list class)))
(let ((slotd (find-slot-definition class slot-name)))
(let ((class (and (constantp class-form) (constant-form-value class-form)))
(slot-name (and (constantp slot-name-form)
(constant-form-value 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)
+ (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)))
(standard-class-p class)
(not (eq class *the-class-t*)) ; shouldn't happen, though.
(let ((slotd (find-slot-definition class slot-name)))
(let ((class (and (constantp class-form) (constant-form-value class-form)))
(slot-name (and (constantp slot-name-form)
(constant-form-value 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)
+ (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
(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
(built-in (find-class 'built-in-class))
(frc (find-class 'forward-referenced-class)))
(flet ((specializer->metatype (x)
(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)))
(specializer-class-or-nil x)
x))
(meta-specializer (class-of specializer-class)))
;;; 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".)
;;; 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".)
projects / sbcl.git / commitdiff