X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=9a718ab923472873129d007b0e991cde2e30af5f;hb=0ee1135a83da462e6de2a98bb2eff837b278f926;hp=6cd5a770cacae11c93d8c449edcd9ca16bd25770;hpb=f19ae86fb2c16ebb4dce3d16cc1bb32e94f07110;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 6cd5a77..9a718ab 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -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)))) @@ -314,7 +315,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 +329,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 +362,11 @@ :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)) (:metaclass funcallable-standard-class) (:default-initargs :method-class *the-class-standard-method* :method-combination *standard-method-combination*)) @@ -366,21 +374,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))) @@ -458,6 +456,9 @@ :initarg :initargs :accessor slot-definition-initargs) (%type :initform t :initarg :type :accessor slot-definition-type) + (%type-check-function :initform nil + :initarg type-check-function + :accessor slot-definition-type-check-function) (%documentation :initform nil :initarg :documentation ;; KLUDGE: we need a reader for bootstrapping purposes, in @@ -549,35 +550,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 @@ -599,6 +612,12 @@ (%documentation :initform nil :initarg :documentation) + ;; True if the class definition was compiled with a (SAFETY 3) + ;; optimization policy. + (safe-p + :initform nil + :initarg safe-p + :accessor safe-p) (finalized-p :initform nil :reader class-finalized-p))) @@ -641,7 +660,32 @@ :accessor class-direct-slots) (slots :initform () - :accessor class-slots))) + :accessor class-slots) + (slot-vector + :initform #(nil) + :reader class-slot-vector))) + +;;; Make the slot-vector accessed by the after-fixup FIND-SLOT-DEFINITION. +;;; The slot vector is a simple-vector containing plists of slot-definitions +;;; keyd by their names. Slot definitions are put in the position indicated +;;; by (REM (SXHASH SLOT-NAME) (LENGTH SLOT-VECTOR)). +;;; +;;; We make the vector slightly longer then the number of slots both +;;; to reduce collisions (but we're not too picky, really) and to +;;; allow FIND-SLOT-DEFINTIONS work on slotless classes without +;;; needing to check for zero-length vectors. +(defun make-slot-vector (slots) + (let* ((n (+ (length slots) 2)) + (vector (make-array n :initial-element nil))) + (flet ((add-to-vector (name slot) + (setf (svref vector (rem (sxhash name) n)) + (list* name slot (svref vector (rem (sxhash name) n)))))) + (if (eq 'complete *boot-state*) + (dolist (slot slots) + (add-to-vector (slot-definition-name slot) slot)) + (dolist (slot slots) + (add-to-vector (early-slot-definition-name slot) slot)))) + vector)) ;;; The class STD-CLASS is an implementation-specific common ;;; superclass of the classes STANDARD-CLASS and @@ -685,6 +729,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)