X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=777338a6a965ef05141e94a8ad5e72528680449c;hb=4ec0d70e08ea4b512d45ddbd6c82e8f6a91a914f;hp=607f6c5960311b4bdc87a3430e34645baedfc5fe;hpb=4f8f4b25cb564509437d8fc26038143150077f14;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 607f6c5..777338a 100644 --- 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~%~ @@ -62,11 +62,12 @@ ;;; 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)))) @@ -75,7 +76,7 @@ ;; 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 @@ -90,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 @@ -129,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 @@ -157,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*)) @@ -194,12 +195,6 @@ (push (list class-name symbol) *built-in-wrapper-symbols*) symbol))) -(pushnew '%class *var-declarations*) -(pushnew '%variable-rebinding *var-declarations*) - -(defun variable-class (var env) - (caddr (var-declaration 'class var env))) - (defvar *standard-method-combination*) (defun plist-value (object name) @@ -232,10 +227,10 @@ (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) @@ -314,7 +309,9 @@ definition-source-mixin metaobject funcallable-standard-object) - ((%documentation :initform nil :initarg :documentation) + ((%documentation + :initform nil + :initarg :documentation) ;; We need to make a distinction between the methods initially set ;; up by :METHOD options to DEFGENERIC and the ones set up later by ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on @@ -326,8 +323,9 @@ ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp ;; tends to leave the generic function in a state consistent with ;; the most-recently-loaded state of a.lisp and b.lisp.) - (initial-methods :initform () - :accessor generic-function-initial-methods)) + (initial-methods + :initform () + :accessor generic-function-initial-methods)) (:metaclass funcallable-standard-class)) (defclass standard-generic-function (generic-function) @@ -358,7 +356,16 @@ :reader gf-arg-info) (dfun-state :initform () - :accessor gf-dfun-state)) + :accessor gf-dfun-state) + ;; Used to make DFUN-STATE & FIN-FUNCTION updates atomic. + (%lock + :initform (sb-thread::make-spinlock :name "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*)) @@ -366,21 +373,11 @@ (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))) @@ -552,35 +549,47 @@ ;; 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 @@ -647,10 +656,10 @@ (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 @@ -659,10 +668,14 @@ ()) (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) ()) @@ -671,15 +684,9 @@ (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 @@ -694,6 +701,7 @@ (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)