;;; 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~%~
;;; interface
(defun specializer-from-type (type &aux args)
+ (when (symbolp type)
+ (return-from specializer-from-type (find-class type)))
(when (consp type)
(setq args (cdr type) type (car type)))
(cond ((symbolp type)
- (or (and (null args) (find-class type))
- (ecase type
+ (or (ecase type
(class (coerce-to-class (car args)))
(prototype (make-instance 'class-prototype-specializer
:object (coerce-to-class (car args))))
;; FIXME: do we still need this?
((and (null args) (typep type 'classoid))
(or (classoid-pcl-class type)
- (ensure-non-standard-class (classoid-name type))))
+ (ensure-non-standard-class (classoid-name type) type)))
((specializerp type) type)))
;;; interface
(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
(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
(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*))
(push (list class-name symbol) *built-in-wrapper-symbols*)
symbol)))
\f
-(pushnew '%class *var-declarations*)
-(pushnew '%variable-rebinding *var-declarations*)
-
-(defun variable-class (var env)
- (caddr (var-declaration 'class var env)))
-
(defvar *standard-method-combination*)
\f
(defun plist-value (object name)
(let ((subs (classoid-subclasses class)))
(/noshow subs)
(when subs
- (dohash (sub v subs)
+ (dohash ((sub v) subs)
(declare (ignore v))
(/noshow sub)
- (when (member class (direct-supers sub))
+ (when (member class (direct-supers sub) :test #'eq)
(res sub)))))
(res))))
(mapcar (lambda (kernel-bic-entry)
;; Used to make DFUN-STATE & FIN-FUNCTION updates atomic.
(%lock
:initform (sb-thread::make-spinlock :name "GF lock")
- :reader gf-lock))
+ :reader gf-lock)
+ ;; Set to true by ADD-METHOD, REMOVE-METHOD; to false by
+ ;; MAYBE-UPDATE-INFO-FOR-GF.
+ (info-needs-update
+ :initform nil
+ :accessor gf-info-needs-update))
(:metaclass funcallable-standard-class)
(:default-initargs :method-class *the-class-standard-method*
:method-combination *standard-method-combination*))
(defclass method (metaobject) ())
(defclass standard-method (plist-mixin definition-source-mixin method)
- ((%generic-function
- :initform nil
- :accessor method-generic-function)
- (qualifiers
- :initform ()
- :initarg :qualifiers
- :reader method-qualifiers)
- (specializers
- :initform ()
- :initarg :specializers
- :reader method-specializers)
- (lambda-list
- :initform ()
- :initarg :lambda-list
- :reader method-lambda-list)
+ ((%generic-function :initform nil :accessor method-generic-function)
+ (qualifiers :initform () :initarg :qualifiers :reader method-qualifiers)
+ (specializers :initform () :initarg :specializers
+ :reader method-specializers)
+ (lambda-list :initform () :initarg :lambda-list :reader method-lambda-list)
(%function :initform nil :initarg :function :reader method-function)
(%documentation :initform nil :initarg :documentation)))
;; responses in comp.lang.lisp). -- CSR, 2006-02-27
((%type :initform nil :reader specializer-type)))
+;;; STANDARD in this name doesn't mean "blessed by a standard" but
+;;; "comes as standard with PCL"; that is, it includes CLASS-EQ
+;;; and vestiges of PROTOTYPE specializers
+(defclass standard-specializer (specializer) ())
+
(defclass specializer-with-object (specializer) ())
(defclass exact-class-specializer (specializer) ())
-(defclass class-eq-specializer (exact-class-specializer
+(defclass class-eq-specializer (standard-specializer
+ exact-class-specializer
specializer-with-object)
((object :initarg :class
:reader specializer-class
:reader specializer-object)))
-(defclass class-prototype-specializer (specializer-with-object)
+(defclass class-prototype-specializer (standard-specializer specializer-with-object)
((object :initarg :class
:reader specializer-class
:reader specializer-object)))
-(defclass eql-specializer (exact-class-specializer specializer-with-object)
+(defclass eql-specializer (standard-specializer exact-class-specializer specializer-with-object)
((object :initarg :object :reader specializer-object
:reader eql-specializer-object)))
(defvar *eql-specializer-table* (make-hash-table :test 'eql))
+(defvar *eql-specializer-table-lock*
+ (sb-thread::make-spinlock :name "EQL-specializer table lock"))
+
(defun intern-eql-specializer (object)
- (or (gethash object *eql-specializer-table*)
- (setf (gethash object *eql-specializer-table*)
- (make-instance 'eql-specializer :object object))))
+ ;; Need to lock, so that two threads don't get non-EQ specializers
+ ;; for an EQL object.
+ (sb-thread::with-spinlock (*eql-specializer-table-lock*)
+ (or (gethash object *eql-specializer-table*)
+ (setf (gethash object *eql-specializer-table*)
+ (make-instance 'eql-specializer :object object)))))
(defclass class (dependent-update-mixin
definition-source-mixin
- specializer)
+ standard-specializer)
((name
:initform nil
:initarg :name
(defclass slot-class (pcl-class)
((direct-slots
:initform ()
- :accessor class-direct-slots)
+ :reader class-direct-slots)
(slots
:initform ()
- :accessor class-slots)))
+ :reader class-slots)))
;;; The class STD-CLASS is an implementation-specific common
;;; superclass of the classes STANDARD-CLASS and
())
(defclass standard-class (std-class)
- ())
+ ()
+ (:default-initargs
+ :direct-superclasses (list *the-class-standard-object*)))
(defclass funcallable-standard-class (std-class)
- ())
+ ()
+ (:default-initargs
+ :direct-superclasses (list *the-class-funcallable-standard-object*)))
(defclass forward-referenced-class (pcl-class) ())
(defclass condition-class (slot-class) ())
(defclass structure-class (slot-class)
- ((defstruct-form
- :initform ()
- :accessor class-defstruct-form)
- (defstruct-constructor
- :initform nil
- :accessor class-defstruct-constructor)
- (from-defclass-p
- :initform nil
- :initarg :from-defclass-p)))
+ ((defstruct-form :initform () :accessor class-defstruct-form)
+ (defstruct-constructor :initform nil :accessor class-defstruct-constructor)
+ (from-defclass-p :initform nil :initarg :from-defclass-p)))
(defclass definition-source-mixin (standard-object)
((source
(defparameter *early-class-predicates*
'((specializer specializerp)
+ (standard-specializer standard-specializer-p)
(exact-class-specializer exact-class-specializer-p)
(class-eq-specializer class-eq-specializer-p)
(eql-specializer eql-specializer-p)