X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=f1e50b9e6c276670cd866a798682eb11ee193877;hb=f07f32b901e342331848c83e26cfbe2f50f4e949;hp=9a718ab923472873129d007b0e991cde2e30af5f;hpb=0ee1135a83da462e6de2a98bb2eff837b278f926;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 9a718ab..f1e50b9 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~%~ @@ -76,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 @@ -91,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 @@ -130,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 @@ -155,16 +155,14 @@ ;;; ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use ;;; in the compiler. Could we share some of it here? +(defvar *in-*subtypep* nil) + (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*)) - ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a - ;; good name. It changes the way - ;; CLASS-APPLICABLE-USING-CLASS-P works. + (let ((*in-*subtypep* t)) (setq type1 (*normalize-type type1)) (setq type2 (*normalize-type type2)) (case (car type2) @@ -195,12 +193,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) @@ -233,10 +225,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) @@ -365,8 +357,13 @@ :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)) + :initform (sb-thread:make-mutex :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*)) @@ -380,7 +377,13 @@ :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))) + (%documentation :initform nil :initarg :documentation) + ;; True IFF method is known to have no CALL-NEXT-METHOD in it, or + ;; just a plain (CALL-NEXT-METHOD). + (simple-next-method-call + :initform nil + :initarg simple-next-method-call + :reader simple-next-method-call-p))) (defclass accessor-method (standard-method) ((slot-name :initform nil :initarg :slot-name @@ -456,9 +459,6 @@ :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 @@ -504,14 +504,29 @@ ()) (defclass effective-slot-definition (slot-definition) - ((reader-function ; (lambda (object) ...) - :accessor slot-definition-reader-function) - (writer-function ; (lambda (new-value object) ...) - :accessor slot-definition-writer-function) - (boundp-function ; (lambda (object) ...) - :accessor slot-definition-boundp-function) - (accessor-flags - :initform 0))) + ((accessor-flags + :initform 0) + (info + :accessor slot-definition-info))) + +;;; We use a structure here, because fast slot-accesses to this information +;;; are critical to making SLOT-VALUE-USING-CLASS &co fast: places that need +;;; these functions can access the SLOT-INFO directly, avoiding the overhead +;;; of accessing a standard-instance. +(defstruct (slot-info (:constructor make-slot-info + (&key slotd + typecheck + (type t) + (reader + (uninitialized-accessor-function :reader slotd)) + (writer + (uninitialized-accessor-function :writer slotd)) + (boundp + (uninitialized-accessor-function :boundp slotd))))) + (typecheck nil :type (or null function)) + (reader (missing-arg) :type function) + (writer (missing-arg) :type function) + (boundp (missing-arg) :type function)) (defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition) @@ -577,13 +592,10 @@ (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) ;; 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*) + (with-locked-system-table (*eql-specializer-table*) (or (gethash object *eql-specializer-table*) (setf (gethash object *eql-specializer-table*) (make-instance 'eql-specializer :object object))))) @@ -657,35 +669,10 @@ (defclass slot-class (pcl-class) ((direct-slots :initform () - :accessor class-direct-slots) + :reader class-direct-slots) (slots :initform () - :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)) + :reader class-slots))) ;;; The class STD-CLASS is an implementation-specific common ;;; superclass of the classes STANDARD-CLASS and @@ -694,10 +681,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) ()) @@ -706,15 +697,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