X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=597a1b2b5a65fae27b6e85895dbdaba0f7a9436a;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=e2240a13d57a6a61edb28173677261eddae236cf;hpb=15db88b169f732c8d339047bfad92e0725d7cacc;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index e2240a1..597a1b2 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 @@ -154,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) @@ -194,19 +193,8 @@ (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 *name->class->slotd-table* (make-hash-table)) - (defvar *standard-method-combination*) -(defun make-class-predicate-name (name) - (list 'class-predicate name)) - (defun plist-value (object name) (getf (object-plist object) name)) @@ -237,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) @@ -309,7 +297,7 @@ (defclass standard-object (slot-object) ()) -(defclass funcallable-standard-object (standard-object function) +(defclass funcallable-standard-object (function standard-object) () (:metaclass funcallable-standard-class)) @@ -319,7 +307,7 @@ definition-source-mixin metaobject funcallable-standard-object) - ((documentation + ((%documentation :initform nil :initarg :documentation) ;; We need to make a distinction between the methods initially set @@ -342,7 +330,7 @@ ((name :initform nil :initarg :name - :accessor generic-function-name) + :reader generic-function-name) (methods :initform () :accessor generic-function-methods @@ -350,7 +338,7 @@ (method-class :initarg :method-class :accessor generic-function-method-class) - (method-combination + (%method-combination :initarg :method-combination :accessor generic-function-method-combination) (declarations @@ -366,64 +354,65 @@ :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-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*)) (defclass method (metaobject) ()) -(defclass standard-method (definition-source-mixin plist-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) - (function - :initform nil - :initarg :function) ;no writer - (fast-function - :initform nil - :initarg :fast-function ;no writer - :reader method-fast-function) - (documentation +(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) + (%function :initform nil :initarg :function :reader method-function) + (%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 :documentation))) + :initarg simple-next-method-call + :reader simple-next-method-call-p))) -(defclass standard-accessor-method (standard-method) - ((slot-name :initform nil - :initarg :slot-name - :reader accessor-method-slot-name) - (slot-definition :initform nil - :initarg :slot-definition - :reader accessor-method-slot-definition))) +(defclass accessor-method (standard-method) + ((slot-name :initform nil :initarg :slot-name + :reader accessor-method-slot-name))) + +(defclass standard-accessor-method (accessor-method) + ((%slot-definition :initform nil :initarg :slot-definition + :reader accessor-method-slot-definition))) (defclass standard-reader-method (standard-accessor-method) ()) (defclass standard-writer-method (standard-accessor-method) ()) ;;; an extension, apparently. (defclass standard-boundp-method (standard-accessor-method) ()) +;;; for (SLOT-VALUE X 'FOO) / ACCESSOR-SLOT-VALUE optimization, which +;;; can't be STANDARD-READER-METHOD because there is no associated +;;; slot definition. +(defclass global-reader-method (accessor-method) ()) +(defclass global-writer-method (accessor-method) ()) +(defclass global-boundp-method (accessor-method) ()) + (defclass method-combination (metaobject) - ((documentation - :reader method-combination-documentation - :initform nil - :initarg :documentation))) + ((%documentation :initform nil :initarg :documentation))) (defclass standard-method-combination (definition-source-mixin method-combination) - ((type - :reader method-combination-type - :initarg :type) + ((type-name + :reader method-combination-type-name + :initarg :type-name) (options :reader method-combination-options :initarg :options))) @@ -436,6 +425,14 @@ :initarg :args-lambda-list :reader long-method-combination-args-lambda-list))) +(defclass short-method-combination (standard-method-combination) + ((operator + :reader short-combination-operator + :initarg :operator) + (identity-with-one-argument + :reader short-combination-identity-with-one-argument + :initarg :identity-with-one-argument))) + (defclass slot-definition (metaobject) ((name :initform nil @@ -449,29 +446,17 @@ :initform nil :initarg :initfunction :accessor slot-definition-initfunction) - (readers - :initform nil - :initarg :readers - :accessor slot-definition-readers) - (writers - :initform nil - :initarg :writers - :accessor slot-definition-writers) (initargs :initform nil :initarg :initargs :accessor slot-definition-initargs) - (type - :initform t - :initarg :type - :accessor slot-definition-type) - (documentation - :initform nil - :initarg :documentation) - (class - :initform nil - :initarg :class - :accessor slot-definition-class))) + (%type :initform t :initarg :type :accessor slot-definition-type) + (%documentation + :initform nil :initarg :documentation + ;; KLUDGE: we need a reader for bootstrapping purposes, in + ;; COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS. + :reader %slot-definition-documentation) + (%class :initform nil :initarg :class :accessor slot-definition-class))) (defclass standard-slot-definition (slot-definition) ((allocation @@ -508,17 +493,39 @@ :accessor slot-definition-internal-writer-function))) (defclass direct-slot-definition (slot-definition) - ()) + ((readers + :initform nil + :initarg :readers + :accessor slot-definition-readers) + (writers + :initform nil + :initarg :writers + :accessor slot-definition-writers))) (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) @@ -547,41 +554,58 @@ ()) (defclass specializer (metaobject) - ((type :initform nil :reader specializer-type))) + ;; KLUDGE: in sbcl-0.9.10.2 this was renamed from TYPE, which was an + ;; external symbol of the CL package and hence potentially collides + ;; with user code. Renaming this to %TYPE, however, is the coward's + ;; way out, because the objects that PCL puts in this slot aren't + ;; (quite) types: they are closer to kinds of specializer. However, + ;; the wholesale renaming and disentangling of specializers didn't + ;; appeal. (See also message and + ;; 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)) (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. + (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))))) (defclass class (dependent-update-mixin definition-source-mixin - specializer) + standard-specializer) ((name :initform nil - :initarg :name - :accessor class-name) + :initarg :name + :reader class-name) (class-eq-specializer :initform nil :reader class-eq-specializer) @@ -596,12 +620,15 @@ :reader class-direct-subclasses) (direct-methods :initform (cons nil nil)) - (predicate-name - :initform nil - :reader class-predicate-name) - (documentation + (%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))) @@ -619,7 +646,7 @@ ;;; The class PCL-CLASS is an implementation-specific common ;;; superclass of all specified subclasses of the class CLASS. (defclass pcl-class (class) - ((class-precedence-list + ((%class-precedence-list :reader class-precedence-list) ;; KLUDGE: see note in CPL-OR-NIL (cpl-available-p @@ -641,10 +668,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 @@ -653,10 +680,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) ()) @@ -665,27 +696,24 @@ (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 :initform *load-pathname* :reader definition-source - :initarg :definition-source))) + ((source + :initform nil + :reader definition-source + :initarg :definition-source))) (defclass plist-mixin (standard-object) - ((plist :initform () :accessor object-plist))) + ((plist :initform () :accessor object-plist :initarg plist))) (defclass dependent-update-mixin (plist-mixin) ()) (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) @@ -699,12 +727,16 @@ (forward-referenced-class forward-referenced-class-p) (method method-p) (standard-method standard-method-p) + (accessor-method accessor-method-p) (standard-accessor-method standard-accessor-method-p) (standard-reader-method standard-reader-method-p) (standard-writer-method standard-writer-method-p) (standard-boundp-method standard-boundp-method-p) + (global-reader-method global-reader-method-p) + (global-writer-method global-writer-method-p) + (global-boundp-method global-boundp-method-p) (generic-function generic-function-p) (standard-generic-function standard-generic-function-p) (method-combination method-combination-p) - (long-method-combination long-method-combination-p))) - + (long-method-combination long-method-combination-p) + (short-method-combination short-method-combination-p)))