;;; 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))))
(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 *name->class->slotd-table* (make-hash-table))
-
(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))
(defclass standard-object (slot-object) ())
-(defclass funcallable-standard-object (standard-object function)
+(defclass funcallable-standard-object (function standard-object)
()
(:metaclass funcallable-standard-class))
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
;; 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)
: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*))
(defclass method (metaobject) ())
-(defclass standard-method (definition-source-mixin plist-mixin method)
- ((%generic-function
- :initform nil
- :accessor method-generic-function)
- #+nil ; implemented by PLIST
- (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)
- (fast-function
- :initform nil
- :initarg :fast-function ;no writer
- :reader method-fast-function)
+(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)))
-(defclass standard-accessor-method (standard-method)
+(defclass 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-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) ())
;;; 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 :initform nil :initarg :documentation)))
: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
())
(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 <sqd5hrclb2.fsf@cam.ac.uk> 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))
+(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
(%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)))
(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
: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)
(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)
projects / sbcl.git / blobdiff